unit vdbg.win;

interface

{$mode delphi}

uses
  SysUtils,
  Classes,
  LCLProc,

  gmap,
  gutil,

  Windows,

  Debugger,
  DebugUtils,

  vdbg.common,
  vdbg.win.helpers,

  vdbg.dbgapi;

type

  TInternalBpInfo = record
    OriginalByte: Byte;
  end;

  TVDbgAddrLess = TLess<TVDbgAddr>;

  TBpMap = TMap<TVDbgAddr, TInternalBpInfo, TVDbgAddrLess>;

  { TWinDbgApi }

  TWinDbgApi = class(TVDbgApi)
  private
    FProcessHandle: HANDLE;
    FProcessId: TVDbgProcessId;

    // Current debug event obtained with WaitForDebugEvent.
    FWinEvent: TDebugEvent;

    FBpMap: TBpMap;
  private
    FNeedPrivileges: boolean;
    FInitialBreakpointDone: boolean;
    procedure DoCloseHandle(AHandle: HANDLE);
    function ReadDbgOutputString(const EventInfo: OUTPUT_DEBUG_STRING_INFO): string;
    procedure do_EXCEPTION_DEBUG_EVENT(const winExcRec: EXCEPTION_RECORD; var Exc: TVDbgExceptionInfo);
    procedure GetPrivileges;
  private
    FThreadContextAllocationBase: Pointer;
    FThreadContext: PVDbgThreadContext;
    procedure ThreadContextAllocate;
    procedure ThreadContextDeallocate;
  public
    constructor Create; override;
    destructor Destroy; override;
  public
    function CreateProcess(const FileName: string; const Arguments: string): boolean; override;
    function AttachToProcess(PID: TVDbgProcessId): boolean; override;
    function Detach: boolean; override;
    function TerminateProcess: boolean; override;
    function WaitForDebugEvent(TimeOut: integer): boolean; override;
    function ContinueEvent(ThreadId: TVDbgThreadId; Handled: boolean): boolean; override;
    function DebugBreak: boolean; override;
    function GetThreadContext: PVDbgThreadContext; override;
    function SetThreadContext(pCtx: PVDbgThreadContext): boolean; override;
    function SetBreakpoint(const Info: TVDbgBreakpointInfo): Boolean; override;
    function DelBreakpoint(const Addr: TVDbgAddr): Boolean; override;
  end;

implementation

{ TWinDbgApi }

procedure TWinDbgApi.DoCloseHandle(AHandle: HANDLE);
begin
  if (AHandle <> 0) and (AHandle <> INVALID_HANDLE_VALUE) then
    Windows.CloseHandle(AHandle);
end;

function TWinDbgApi.ReadDbgOutputString(
  const EventInfo: OUTPUT_DEBUG_STRING_INFO): string;
var
  StrA: AnsiString;
  LenRead: DWORD;
begin
  // http://msdn.microsoft.com/en-us/library/windows/desktop/ms680545(v=vs.85).aspx

  // Actually there should never be unicode string.
  Assert(EventInfo.fUnicode = 0);

  Result := '';

  // Shouldn't happen. Just paranoic.
  if EventInfo.nDebugStringLength = 0 then
     Exit;

  // Allocate string (without trailing zero)
  SetLength(StrA, EventInfo.nDebugStringLength - 1);

  if Windows.ReadProcessMemory(FProcessHandle, EventInfo.lpDebugStringData,
    @StrA[1], Length(StrA), LenRead) then
  begin
    if LenRead = Length(StrA) then
    begin
      StrA := MakePrintable(UnEscapeBackslashed(StrA, [uefOctal, uefTab, uefNewLine]));
      Result := StrA;
    end;
  end;
end;

procedure TWinDbgApi.do_EXCEPTION_DEBUG_EVENT(
  const winExcRec: EXCEPTION_RECORD; var Exc: TVDbgExceptionInfo);
begin
  case winExcRec.ExceptionCode of
    STATUS_BREAKPOINT:
    begin
      FEvent.&Type := dbgevt_breakpoint;
      FEvent.Breakpoint.Address := TVDbgAddr(winExcRec.ExceptionAddress);
      if not FInitialBreakpointDone then
      begin
        FEvent.Breakpoint.Initial := not FInitialBreakpointDone;
        FInitialBreakpointDone := True;
      end
      else
        FEvent.Breakpoint.Initial := False;
    end;
    else
      // Any other exception.
      FEvent.&Type := dbgevt_exception;
      Exc.Address := TVDbgAddr(winExcRec.ExceptionAddress);
      Exc.Code := winExcRec.ExceptionCode;
  end;
end;

procedure TWinDbgApi.GetPrivileges;
begin
  if FNeedPrivileges then
  begin
    if SetPrivilegeByName(SE_DEBUG_NAME, True) then
      DebugLn('Debug privileges obtained.')
    else
      DebugLn('Debug privileges not obtained.');
  end;
end;

procedure TWinDbgApi.ThreadContextAllocate;
begin
  FThreadContextAllocationBase := AllocMem(SizeOf(TVDbgThreadContext) + 16);
  FThreadContext := Pointer((PtrUInt(FThreadContextAllocationBase) + 16) and $FFFFFFFFFFFFFFF0);
end;

procedure TWinDbgApi.ThreadContextDeallocate;
begin
  Freemem(FThreadContextAllocationBase);
  FThreadContextAllocationBase := nil;
end;

constructor TWinDbgApi.Create;
begin
  inherited Create;
  FBpMap := TBpMap.Create;
  DebugLn('[TWinDbgApi.Create] FBpMap create = %p', [Pointer(FBpMap)]);
  ThreadContextAllocate;
end;

destructor TWinDbgApi.Destroy;
begin
  FBpMap.Free;
  ThreadContextDeallocate;
  inherited Destroy;
end;

function TWinDbgApi.CreateProcess(const FileName: string;
  const Arguments: string): boolean;
var
  FileNameOfProcessToCreate: WideString;
  CommandLine: WideString;
  StartupInfo: TSTARTUPINFO;
  ProcessInfo: TPROCESSINFORMATION;
  dwCreationFlags: DWORD;
begin
  GetPrivileges;

  FillChar(StartupInfo, SizeOf(StartupInfo), 0);
  StartupInfo.cb := SizeOf(StartupInfo);

  FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);

  FileNameOfProcessToCreate := FileName;
  CommandLine := Format('"%s" %s', [FileName, Arguments]);

  dwCreationFlags :=
    // debug only child process
    DEBUG_ONLY_THIS_PROCESS or
    // child must have new console
    CREATE_NEW_CONSOLE;

  Result := Windows.CreateProcessW(
         PWideChar(FileNameOfProcessToCreate), // app file name
         PWideChar(CommandLine), // cmdline
         nil, // process attributes
         nil, // thread attributes
         false, // bInheritHandles
         dwCreationFlags,
         nil, // lpEnvironment
         nil, // lpCurrentDirectory
         StartupInfo,
         ProcessInfo
         );

  if Result then
  begin
    FDebuggeeFileName := FileName;
    FProcessHandle := ProcessInfo.hProcess;
    FProcessId := ProcessInfo.dwProcessId;
  end;
end;

function TWinDbgApi.AttachToProcess(PID: TVDbgProcessId): boolean;
begin
  GetPrivileges;

  Result := Windows.DebugActiveProcess(PID);
  if Result then
  begin
    FProcessId := PID;
    FProcessHandle := 0;
  end;
end;

function TWinDbgApi.Detach: boolean;
begin
  Result := DebugActiveProcessStop(FProcessId);
  DebugLn('Detaching from process %d: %s', [FProcessId, BoolToStr(result, True)]);
end;

function TWinDbgApi.TerminateProcess: boolean;
begin
  Result := Windows.TerminateProcess(FProcessHandle, 0);
end;

function TWinDbgApi.WaitForDebugEvent(TimeOut: integer): boolean;
begin
  Result := Windows.WaitForDebugEvent(FWinEvent, TimeOut);
  if not Result then
     Exit;

  // Parse FWinEvent and construct Event.

  FEvent.ThreadId := FWinEvent.dwThreadId;
  FEvent.&Type := dbgevt_null;

  case FWinEvent.dwDebugEventCode of
    CREATE_PROCESS_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_process_create;
      FProcessHandle := FWinEvent.CreateProcessInfo.hProcess;
      DoCloseHandle(FWinEvent.CreateProcessInfo.hFile);
    end;
    EXIT_PROCESS_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_process_exit;
      FEvent.ProcessExit.ExitCode := FWinEvent.ExitProcess.dwExitCode;
    end;
    CREATE_THREAD_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_thread_create;
    end;
    EXIT_THREAD_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_thread_exit;
      FEvent.ThreadExit.ExitCode := FWinEvent.ExitThread.dwExitCode;
    end;
    LOAD_DLL_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_module_load;
      FEvent.ModuleLoad.Base := TVDbgAddr(FWinEvent.LoadDll.lpBaseOfDll);
      FLoadedModuleFilename := GetFileNameFromHandle(FWinEvent.LoadDll.hFile);
      DoCloseHandle(FWinEvent.LoadDll.hFile);
    end;
    UNLOAD_DLL_DEBUG_EVENT:
    begin
      FEvent.&Type := dbgevt_module_unload;
      FEvent.ModuleUnload.Base := TVDbgAddr(FWinEvent.UnloadDll.lpBaseOfDll);
    end;
    OUTPUT_DEBUG_STRING_EVENT:
    begin
      FEvent.&Type := dbgevt_output_string;
      FDebugOutputString := ReadDbgOutputString(FWinEvent.DebugString);
    end;
    EXCEPTION_DEBUG_EVENT:
    begin
      do_EXCEPTION_DEBUG_EVENT(FWinEvent.Exception.ExceptionRecord, FEvent.Exception);
    end;
  end;
end;

function TWinDbgApi.ContinueEvent(ThreadId: TVDbgThreadId; Handled: boolean): boolean;
var
  Status: DWORD;
begin
  if Handled then
    Status := DBG_CONTINUE
  else
    Status := DBG_EXCEPTION_NOT_HANDLED;
  Result := Windows.ContinueDebugEvent(FProcessId, ThreadId, Status);
end;

function TWinDbgApi.DebugBreak: boolean;
begin
  Result := DebugBreakProcess(FProcessHandle);
end;

function TWinDbgApi.GetThreadContext: PVDbgThreadContext;
var
  hThread: HANDLE;
  dwSuspend: DWORD;
begin
  Result := nil;

  hThread := OpenThread(
    // http://www.nynaeve.net/?p=129
    // WOW64: The handle must also have THREAD_QUERY_INFORMATION access.
    THREAD_ALL_ACCESS or THREAD_QUERY_INFORMATION,
    False,
    FWinEvent.dwThreadId);

  if hThread = 0 then
     Exit;

  DebugLn('[TWinDbgApi.GetThreadContext] hThread: %x', [hThread]);

  try
    dwSuspend := SuspendThread(hThread);

    DebugLn('[TWinDbgApi.GetThreadContext] dwSuspend: %x', [dwSuspend]);

    if dwSuspend = DWORD(-1) then
       Exit;

    try
      FThreadContext^.ContextFlags := CONTEXT_FULL;
      if Windows.GetThreadContext(hThread, FThreadContext) then
        Result := FThreadContext
      else
        DebugLn(SysErrorMessage(GetLastError));
    finally
      ResumeThread(hThread);
    end;
  finally
    CloseThread(hThread);
  end;
end;

function TWinDbgApi.SetThreadContext(pCtx: PVDbgThreadContext): boolean;
var
  hThread: HANDLE;
  dwSuspend: DWORD;
begin
  Result := False;

  hThread := OpenThread(
    THREAD_ALL_ACCESS or THREAD_QUERY_INFORMATION,
    False,
    FWinEvent.dwThreadId);

  if hThread = 0 then
     Exit;

  try
    dwSuspend := SuspendThread(hThread);

    if dwSuspend = DWORD(-1) then
       Exit;

    try
      FThreadContext^.ContextFlags := CONTEXT_FULL;
      if Windows.SetThreadContext(hThread, FThreadContext^) then
        Result := True
      else
        DebugLn(SysErrorMessage(GetLastError));
    finally
      ResumeThread(hThread);
    end;
  finally
    CloseThread(hThread);
  end;
end;

function TWinDbgApi.SetBreakpoint(const Info: TVDbgBreakpointInfo): Boolean;
const
  INT_3: byte = $cc;
  BP_SIZE = 1;
var
  BpIntInfo: TInternalBpInfo;
begin
  // Now it's very simplified. Just an experiment.
  // Simply write CC(int 3) w/o additional checks.

  if FBpMap.TryGetValue(Info.Address, BpIntInfo) then
  begin
    DebugLn('[TWinDbgApi.SetBreakpoint] bp at %x already exists', [Info.Address]);
    Exit(False);
  end;

  // Get original byte.
  if not ReadProcessMemory(FProcessHandle, Pointer(Info.Address), @BpIntInfo.OriginalByte, BP_SIZE, nil) then
    Exit(False);

  // Write 'int 3'
  if not WriteProcessMemory(FProcessHandle, Pointer(Info.Address), @INT_3, BP_SIZE, nil) then
    Exit(False);

  // Update cache.
  Windows.FlushInstructionCache(FProcessHandle, Pointer(Info.Address), BP_SIZE);

  FBpMap.Insert(Info.Address, BpIntInfo);

  DebugLn('[TWinDbgApi.SetBreakpoint] %x, org. byte: %x', [Info.Address, BpIntInfo.OriginalByte]);

  Exit(True);
end;

function TWinDbgApi.DelBreakpoint(const Addr: TVDbgAddr): Boolean;
const
  BP_SIZE = 1;
var
  BpIntInfo: TInternalBpInfo;
begin
  if not FBpMap.TryGetValue(Addr, BpIntInfo) then
  begin
    DebugLn('[TWinDbgApi.DelBreakpoint] bp at %x not found', [Addr]);
    Exit(False);
  end;

  // Restore original byte.
  if not WriteProcessMemory(FProcessHandle, Pointer(Addr), @BpIntInfo.OriginalByte, BP_SIZE, nil) then
    Exit(False);

  // Update cache.
  Windows.FlushInstructionCache(FProcessHandle, Pointer(Addr), BP_SIZE);

  // Remove from breakpoint map.
  FBpMap.Delete(Addr);

  DebugLn('[TWinDbgApi.DelBreakpoint] bp at %x deleted', [Addr]);

  Result := True;
end;

end.
